#lang racket


(require "../base/main.rkt"
         "../proxies/main.rkt")

(require "ac-com.rkt")

(provide
 ; constants
 view-front
 view-neiso
 view-nwiso
 view-seiso
 view-swiso
 
 ; types
 (struct-out extrusion-type-surface)
 (struct-out extrusion-type-solid)
 
 (struct-out loft-type-surface)
 (struct-out loft-type-solid)
 
 (struct-out loft-fit-type-ruled)
 (struct-out loft-fit-type-smooth)
 
 (struct-out render-type-draft)
 (struct-out render-type-presentation)
 
 (struct-out sweep-type-surface)
 (struct-out sweep-type-solid)
 
 (struct-out vscurrent-type-2d-wireframe)
 (struct-out vscurrent-type-conceptual)
 (struct-out vscurrent-type-wireframe)
 
 ; commands
 arc-ppp-command
 cone-frustum-command
 
 dview-command
 dview-zoom-command
 
 entlast-command
 erase-all-command
 extrude-command
 join-command
 
 loft-mark
 loft-command
 
 redo-command
 regen-command
 render-command
 sweep-command
 undo-command
 vscurrent-command
 
 zoom-extents-command
 zoom-objects-command)


; constants

(define view-front "_front")
(define view-neiso "_neiso")
(define view-nwiso "_nwiso")
(define view-seiso "_seiso")
(define view-swiso "_swiso")


; marshaling

(define (string<-coord c)
  (format "~A,~A,~A" (xyz-x c) (xyz-y c) (xyz-z c)))


; lisp

(define (cone-frustum-lisp c base-radius top-radius height)
  (string-append
   "._cone "
   (format "~A,~A,~A " (vector-ref c 0) (vector-ref c 1) (vector-ref c 2))
   (format "~A _T ~A ~A " base-radius top-radius height)))

(define (dview-lisp center target distance)
  (format "._dview  _po ~A ~A _d ~A" target center distance))

(define (dview-zoom-lisp center target lens distance)
  (format "._dview  _z ~A _po ~A ~A _d ~A" lens target center distance))


; extrude

(define surface-extrusion-mode "_su")
(define solid-extrusion-mode "_so")

(define (extrude-length-lisp mode object length)
  (format "._extrude _mo ~A ~A  ~A" mode (handent-lisp (get-object-handle object)) length))

(define (extrude-direction-lisp mode object start-point end-point)
  (format "._extrude _mo ~A ~A  _d ~A ~A" mode (handent-lisp (get-object-handle object)) start-point end-point))

; /extrude


(define (handent-lisp handle)
  (string-append "(handent \"" handle "\")"))

(define (join-lisp objects)
  (apply
   string-append
   "._join "
   (map
    (λ (object)
      (format "~A " (handent-lisp (get-object-handle object))))
    objects)))


; loft

(define surface-loft-mode "_su")
(define solid-loft-mode "_so")

(define (loft-lisp mode objects)
  (format
   "._loft _mo ~A ~A"
   mode
   (string-join (map (λ. handent-lisp get-object-handle) objects) " ")))

; /loft


; render

(define draft-render-quality "D")
(define presentation-render-quality "P")

(define (render-lisp quality width height filename)
  (format "._-render ~A R ~A ~A yes ~A" quality width height filename))

; /render


; sweep

(define surface-sweep-mode "_su")
(define solid-sweep-mode "_so")

(define perpendicular-alignment-sweep-mode "Yes")
(define non-perpendicular-alignment-sweep-mode "No")

(define (sweep-lisp mode object alignment-mode path)
  (format
   "._sweep _mo ~A ~A  _A ~A ~A"
   mode
   (handent-lisp (get-object-handle object))
   alignment-mode
   (handent-lisp (get-object-handle path))))

; /sweep


(define (view-lisp name)
  (format "._-view ~A" name))


; vscurrent

(define vscurrent-style-2d-wireframe "_2dwireframe")
(define vscurrent-style-conceptual "_Conceptual")
(define vscurrent-style-wireframe "_Wireframe")

(define (vscurrent-lisp style)
  (format "._vscurrent ~A" style))

; /vscurrent


; zoom

(define (zoom-extents-lisp)
  (format "._zoom _e"))

(define (zoom-objects-lisp objects)
  (format
   "._zoom _o ~A"
   (string-join (map (λ. handent-lisp get-object-handle) objects) " ")))

; /zoom


; types

(struct extrusion-type ())
(struct extrusion-type-surface extrusion-type ())
(struct extrusion-type-solid extrusion-type ())

(struct loft-type ())
(struct loft-type-surface loft-type ())
(struct loft-type-solid loft-type ())

(struct loft-fit-type ())
(struct loft-fit-type-ruled loft-fit-type ())
(struct loft-fit-type-smooth loft-fit-type ())

(struct render-type ())
(struct render-type-draft render-type ())
(struct render-type-presentation render-type ())

(struct sweep-type ())
(struct sweep-type-surface sweep-type ())
(struct sweep-type-solid sweep-type ())

(struct vscurrent-type ())
(struct vscurrent-type-2d-wireframe vscurrent-type ())
(struct vscurrent-type-conceptual vscurrent-type ())
(struct vscurrent-type-wireframe vscurrent-type ())


; commands

; edit: refactor
; edit: eliminate dependency from arc-ppp
(define (arc-ppp-command c1 c2 c3)
  (let ((c1 (vector<real><-coord c1))
        (c2 (vector<real><-coord c2))
        (c3 (vector<real><-coord c3)))
    (active-document-send-command
     (string-append
      "._arc "
      (format "~A,~A,~A " (vector-ref c1 0) (vector-ref c1 1) (vector-ref c1 2))
      (format "~A,~A " (vector-ref c2 0) (vector-ref c2 1))
      (format "~A,~A " (vector-ref c3 0) (vector-ref c3 1))))
    (entlast-command)))

(define (cone-frustum-command c base-radius top-radius height)
  (active-document-send-command
   (cone-frustum-lisp
    (vector<real><-coord c)
    (real<-number base-radius)
    (real<-number top-radius)
    (real<-number height)))
  (entlast-command))

(define (dview-command center target distance)
  (active-document-send-command
   (string-append
    (dview-lisp
     (string<-coord center)
     (string<-coord target)
     (real<-number distance))
    vbCr)))

(define (dview-zoom-command center target lens distance)
  (active-document-send-command
   (string-append
    (dview-zoom-lisp
     (string<-coord center)
     (string<-coord target)
     (real<-number lens)
     (real<-number distance))
    vbCr)))

; edit: name is not consistent with the others
(define (entlast-command)
  (active-modelspace-item (- (get-active-modelspace-count) 1)))

; edit: create lisp function
(define (erase-all-command)
  (active-document-send-command
   (string-append "erase all" vbCr)))

; edit: introduce object handle here?
(define extrude-command
  (case-lambda
    ((extrusion-type object length)
     (let ((extrusion-mode
            (match extrusion-type
              ((extrusion-type-surface) surface-extrusion-mode)
              ((extrusion-type-solid) solid-extrusion-mode))))
       (active-document-send-command
        (format
         "~A "
         (extrude-length-lisp extrusion-mode object (real<-number length))))
       (entlast-command)))
    ((extrusion-type object start-point end-point)
     (let ((extrusion-mode
            (match extrusion-type
              ((extrusion-type-surface) surface-extrusion-mode)
              ((extrusion-type-solid) solid-extrusion-mode))))
       (active-document-send-command
        (format
         "~A "
         (extrude-direction-lisp
          extrusion-mode
          object
          (string<-coord start-point)
          (string<-coord end-point))))
       (entlast-command)))))

(define (join-command objects)
  (active-document-send-command
   (format "~A " (join-lisp objects)))
  (first objects))


; loft

(define (pop-entities n)
  (map active-modelspace-item (reverse (: < n .. (get-active-modelspace-count) <))))

(define loft-entities (make-parameter #f))

(define (loft-mark)
  (loft-entities (get-active-modelspace-count)))

(define (loft-command loft-type loft-fit-type closed? objects)
  (let ((previous-param (get-loft-param-variable))
        (previous-normals (get-loft-normals-variable)))
    (let ((mode
           (match loft-type
             ((loft-type-surface) surface-loft-mode)
             ((loft-type-solid) solid-loft-mode)))
          (param
           (if closed?
               (cons 'close previous-param)
               (remq 'close previous-param)))
          (normals
           (match loft-fit-type
             ((loft-fit-type-ruled) 'ruled)
             ((loft-fit-type-smooth) 'smooth-fit))))
      (set-loft-param-variable! param)
      (set-loft-normals-variable! normals)
      (active-document-send-command (string-append (loft-lisp mode objects) vbCr "\n"))
      (set-loft-param-variable! previous-param)
      (set-loft-normals-variable! previous-normals)
      (pop-entities (loft-entities)))))

; /loft


(define (redo-command)
  (active-document-send-command (string-append "redo" vbCr)))

(define (regen-command)
  (active-document-send-command (string-append "regen" vbCr)))

(define (render-command type width height filename)
  (let ((quality
         (match type
           ((render-type-draft) draft-render-quality)
           ((render-type-presentation) presentation-render-quality))))
    (active-document-send-command (string-append (render-lisp quality width height filename) "\n"))))

(define (sweep-command sweep-type object path)
  (let ((sweep-mode
         (match sweep-type
           ((sweep-type-surface) surface-sweep-mode)
           ((sweep-type-solid) solid-sweep-mode))))
    (active-document-send-command (string-append (sweep-lisp sweep-mode object perpendicular-alignment-sweep-mode path) " "))
    (entlast-command)))

(define (undo-command)
  (active-document-send-command (string-append "undo" vbCr)))

(define (view-command name)
  (active-document-send-command (string-append (view-lisp name) " ")))

(define (vscurrent-command type)
  (let ((style
         (match type
           ((vscurrent-type-2d-wireframe) vscurrent-style-2d-wireframe)
           ((vscurrent-type-conceptual) vscurrent-style-conceptual)
           ((vscurrent-type-wireframe) vscurrent-style-wireframe))))
    (active-document-send-command (string-append (vscurrent-lisp style) " "))))


; zoom

(define (zoom-extents-command)
  (active-document-send-command (string-append (zoom-extents-lisp) " ")))

(define (zoom-objects-command objects)
  (active-document-send-command (string-append (zoom-objects-lisp objects) vbCr)))

; /zoom